home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / aijournl / 1987_03 / exprt2.mar < prev    next >
Lisp/Scheme  |  1987-02-21  |  3KB  |  74 lines
  1. ; STATE-SPACE SEARCH PROCEDURE
  2. ;   These functions provide a general control structure for
  3. ; solving problems using heuristic search.  In order to apply
  4. ; this method to a particular problem, you must write the
  5. ; functions: initial-state, goal, successors, and print-solution.
  6. ;    See the "Expert's Toolbox" column in the March AI-Expert
  7. ; for a description of this algorithm and an example of its use.
  8. ;
  9. ; Algorithm given by Dr. Ralph Grishman, New York University,
  10. ; after Nils Nilsson, "Principles of Artificial Intelligence".
  11. ; Adapted for Xlisp by Marc Rettig (76703,1037).
  12.  
  13. (defun search ()
  14.     (prog (open closed n m successor-list same)
  15.  
  16.           ; Step 1. Put initial state on open.
  17.           (setq open (list (initial-state)))
  18.  
  19.           ; Step 2. If open is empty, exit with failure.
  20.      expand:
  21.           (cond ((null open) (print 'failure) (return nil)))
  22.  
  23.           ; Step 3. Remove state from open with minimum g + h and
  24.           ;    call it n.  (open is sorted by increasing g + h, so
  25.           ;    this is first element.)  Put n on closed.
  26.           ;    Exit with success if n is a goal node.
  27.           (setq n (car open))
  28.           (setq open (cdr open))
  29.           (setq closed (cons n closed))
  30.           (trace 'expanding n)
  31.           (cond ((goal n) (print-solution n) (return t)))
  32.  
  33.           ; For each m in successors(m):
  34.           (setq successor-list (successors n))
  35.      next-successor:
  36.           (cond ((null successor-list) (go expand:)))
  37.           (setq m (car successor-list))
  38.           (setq successor-list (cdr successor-list))
  39.           (trace 'successor m)
  40.           (cond ((setq same (find m open))
  41.                  ; if m is on open, reset g if new value is smaller
  42.                  (cond
  43.                   ((< (get m 'g) (get same 'g))
  44.                    (setq open (add m (remove same open))))))
  45.                 ((setq same (find m closed))
  46.                  ; If m is on closed and new value of g is smaller,
  47.                  ; remove state from closed and add it to open with new g.
  48.                  (cond
  49.                   ((< (get m 'g) (get same 'g))
  50.                    (setq closed (remove same closed))
  51.                    (setq open (add m open)))))
  52.                 (t 
  53.                   ; else add m to open
  54.                   (setq open (add m open))))
  55.           (go next-successor:)))
  56.  
  57. (defun add (state s-list)
  58.     ; Inserts state into s-list so that list remains ordered
  59.     ; by increasing g + h.
  60.     (cond ((null s-list) (list state))
  61.           ((> (+ (get (car s-list) 'g) (get (car s-list) 'h))
  62.               (+ (get state 'g) (get state 'h)))
  63.            (cons state s-list))
  64.           (t (cons (car s-list) (add state (cdr s-list))))))
  65.  
  66. (defun find (state s-list)
  67.     ; returns first entry on s-list whose position is same
  68.     ; as that of state.
  69.     (cond ((null s-list) nil)
  70.           ((equal (get state 'position)
  71.                   (get (car s-list) 'position))
  72.            (car s-list))
  73.           (t (find state (cdr s-list)))))
  74.